home *** CD-ROM | disk | FTP | other *** search
- ;;; Compiled by f2cl version 2.0 beta 2002-05-06
- ;;;
- ;;; Options: ((:prune-labels nil) (:auto-save t) (:relaxed-array-decls t)
- ;;; (:coerce-assigns :as-needed) (:array-type ':simple-array)
- ;;; (:array-slicing nil) (:declare-common nil)
- ;;; (:float-format double-float))
-
- (in-package "SLATEC")
-
-
- (let ((naif 0)
- (naig 0)
- (naip1 0)
- (naip2 0)
- (x3sml 0.0)
- (x32sml 0.0)
- (xbig 0.0)
- (aifcs (make-array 13 :element-type 'double-float))
- (aigcs (make-array 13 :element-type 'double-float))
- (aip1cs (make-array 57 :element-type 'double-float))
- (aip2cs (make-array 37 :element-type 'double-float))
- (first nil))
- (declare (type f2cl-lib:logical first)
- (type (simple-array double-float (37)) aip2cs)
- (type (simple-array double-float (57)) aip1cs)
- (type (simple-array double-float (13)) aigcs aifcs)
- (type double-float xbig x32sml x3sml)
- (type f2cl-lib:integer4 naip2 naip1 naig naif))
- (f2cl-lib:fset (f2cl-lib:fref aifcs (1) ((1 13))) -0.03797135849667)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (2) ((1 13))) 0.05919188853726364)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (3) ((1 13))) 9.862928057727998e-4)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (4) ((1 13))) 6.848843819076567e-6)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (5) ((1 13))) 2.5942025962194715e-8)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (6) ((1 13))) 6.176612774081375e-11)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (7) ((1 13))) 1.0092454172466117e-13)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (8) ((1 13))) 1.2014792511179939e-16)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (9) ((1 13))) 1.0882945588716993e-19)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (10) ((1 13))) 7.751377219668488e-23)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (11) ((1 13))) 4.454811203717564e-26)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (12) ((1 13))) 2.1092845231692342e-29)
- (f2cl-lib:fset (f2cl-lib:fref aifcs (13) ((1 13))) 8.370173591074134e-33)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (1) ((1 13))) 0.018152365581161272)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (2) ((1 13))) 0.021572563166010757)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (3) ((1 13))) 2.567835698748325e-4)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (4) ((1 13))) 1.4265214119792408e-6)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (5) ((1 13))) 4.572114920018043e-9)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (6) ((1 13))) 9.525170843564709e-12)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (7) ((1 13))) 1.39256346057714e-14)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (8) ((1 13))) 1.5070999142762379e-17)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (9) ((1 13))) 1.2559148312567775e-20)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (10) ((1 13))) 8.306307377082133e-24)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (11) ((1 13))) 4.4657538493718574e-27)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (12) ((1 13))) 1.9900855034518866e-30)
- (f2cl-lib:fset (f2cl-lib:fref aigcs (13) ((1 13))) 7.470288525653334e-34)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (1) ((1 57))) -0.021469518589105386)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (2) ((1 57))) -0.0075353825350433015)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (3) ((1 57))) 5.971527949026381e-4)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (4) ((1 57))) -7.283251254207612e-5)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (5) ((1 57))) 1.1102971307392998e-5)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (6) ((1 57))) -1.9503861522844057e-6)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (7) ((1 57))) 3.786973885159515e-7)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (8) ((1 57))) -7.929675297350979e-8)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (9) ((1 57))) 1.7622476386742564e-8)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (10) ((1 57))) -4.1107675396671944e-9)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (11) ((1 57))) 9.984770057857894e-10)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (12) ((1 57))) -2.510093251387122e-10)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (13) ((1 57))) 6.500501929860696e-11)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (14) ((1 57))) -1.7278184053936166e-11)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (15) ((1 57))) 4.699378842824513e-12)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (16) ((1 57))) -1.3046756562977438e-12)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (17) ((1 57))) 3.689698478462679e-13)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (18) ((1 57))) -1.0610872066468062e-13)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (19) ((1 57))) 3.0984143848781875e-14)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (20) ((1 57))) -9.17490807982414e-15)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (21) ((1 57))) 2.752049140347211e-15)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (22) ((1 57))) -8.353750115922047e-16)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (23) ((1 57))) 2.563931129357935e-16)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (24) ((1 57))) -7.950633762598855e-17)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (25) ((1 57))) 2.48928363460307e-17)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (26) ((1 57))) -7.864326933928737e-18)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (27) ((1 57))) 2.5056873114399764e-18)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (28) ((1 57))) -8.047420364163911e-19)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (29) ((1 57))) 2.604097118952054e-19)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (30) ((1 57))) -8.486954164056414e-20)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (31) ((1 57))) 2.7847068821423376e-20)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (32) ((1 57))) -9.195858953498612e-21)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (33) ((1 57))) 3.055304318374239e-21)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (34) ((1 57))) -1.0210354554794779e-21)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (35) ((1 57))) 3.431118190743757e-22)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (36) ((1 57))) -1.1591293417977495e-22)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (37) ((1 57))) 3.9357728442002554e-23)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (38) ((1 57))) -1.3428809802967176e-23)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (39) ((1 57))) 4.6032878835200025e-24)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (40) ((1 57))) -1.5850439270040642e-24)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (41) ((1 57))) 5.481275667729675e-25)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (42) ((1 57))) -1.903349371855047e-25)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (43) ((1 57))) 6.635682302374009e-26)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (44) ((1 57))) -2.3223116500263147e-26)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (45) ((1 57))) 8.157640113429182e-27)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (46) ((1 57))) -2.875824240632901e-27)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (47) ((1 57))) 1.0173294509429016e-27)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (48) ((1 57))) -3.6108791087422165e-28)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (49) ((1 57))) 1.2857885403639935e-28)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (50) ((1 57))) -4.592901037378547e-29)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (51) ((1 57))) 1.6455970338207138e-29)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (52) ((1 57))) -5.913421299843502e-30)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (53) ((1 57))) 2.1310570066049933e-30)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (54) ((1 57))) -7.701158157787599e-31)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (55) ((1 57))) 2.7905333079689304e-31)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (56) ((1 57))) -1.0138077151112841e-31)
- (f2cl-lib:fset (f2cl-lib:fref aip1cs (57) ((1 57))) 3.6925801587196244e-32)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (1) ((1 37))) -0.0017431449692937551)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (2) ((1 37))) -0.0016789385432554166)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (3) ((1 37))) 3.5965340335216606e-5)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (4) ((1 37))) -1.3808186027392283e-6)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (5) ((1 37))) 7.411228077315053e-8)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (6) ((1 37))) -5.00238203900133e-9)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (7) ((1 37))) 4.0069391741718424e-10)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (8) ((1 37))) -3.673312427959051e-11)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (9) ((1 37))) 3.760344395923738e-12)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (10) ((1 37))) -4.2232133271874756e-13)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (11) ((1 37))) 5.135094540336572e-14)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (12) ((1 37))) -6.690958503904776e-15)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (13) ((1 37))) 9.266675456412906e-16)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (14) ((1 37))) -1.355143824160706e-16)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (15) ((1 37))) 2.0811549631283097e-17)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (16) ((1 37))) -3.3411649915917685e-18)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (17) ((1 37))) 5.585785845859244e-19)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (18) ((1 37))) -9.692190401523653e-20)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (19) ((1 37))) 1.740457001288932e-20)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (20) ((1 37))) -3.226409797311304e-21)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (21) ((1 37))) 6.160744711066252e-22)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (22) ((1 37))) -1.2093634798249005e-22)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (23) ((1 37))) 2.4363276331013814e-23)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (24) ((1 37))) -5.029142214974575e-24)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (25) ((1 37))) 1.0622417554363568e-24)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (26) ((1 37))) -2.2928428489598918e-25)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (27) ((1 37))) 5.051817339295037e-26)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (28) ((1 37))) -1.1349812371441241e-26)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (29) ((1 37))) 2.59765565985607e-27)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (30) ((1 37))) -6.051246215429396e-28)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (31) ((1 37))) 1.433597779667728e-28)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (32) ((1 37))) -3.451477570609e-29)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (33) ((1 37))) 8.438751902136467e-30)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (34) ((1 37))) -2.0939614229818818e-30)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (35) ((1 37))) 5.270088734789455e-31)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (36) ((1 37))) -1.344574330145534e-31)
- (f2cl-lib:fset (f2cl-lib:fref aip2cs (37) ((1 37))) 3.475709645266012e-32)
- (setq first f2cl-lib:%true%)
- (defun daie (x)
- (declare (type double-float x))
- (prog ((sqrtx 0.0) (theta 0.0) (xm 0.0) (z 0.0) (daie 0.0) (eta 0.0f0))
- (declare (type single-float eta)
- (type double-float daie z xm theta sqrtx))
- (cond
- (first (setf eta (* 0.1f0 (f2cl-lib:freal (f2cl-lib:d1mach 3))))
- (setf naif (initds aifcs 13 eta))
- (setf naig (initds aigcs 13 eta))
- (setf naip1 (initds aip1cs 57 eta))
- (setf naip2 (initds aip2cs 37 eta))
- (setf x3sml (coerce (expt eta 0.3333f0) 'double-float))
- (setf x32sml (* 1.3104 (expt x3sml 2)))
- (setf xbig (expt (f2cl-lib:d1mach 2) 0.6666))))
- (setf first f2cl-lib:%false%)
- (if (>= x -1.0) (go label20))
- (multiple-value-bind
- (var-0 var-1 var-2)
- (d9aimp x xm theta)
- (declare (ignore var-0))
- (setf xm var-1)
- (setf theta var-2))
- (setf daie (* xm (cos theta)))
- (go end_label)
- label20
- (if (> x 1.0) (go label30))
- (setf z 0.0)
- (if (> (abs x) x3sml) (setf z (expt x 3)))
- (setf daie
- (+ 0.375
- (- (dcsevl z aifcs naif)
- (* x (+ 0.25 (dcsevl z aigcs naig))))))
- (if (> x x32sml)
- (setf daie (* daie (exp (/ (* 2.0 x (f2cl-lib:fsqrt x)) 3.0)))))
- (go end_label)
- label30
- (if (> x 4.0) (go label40))
- (setf sqrtx (f2cl-lib:fsqrt x))
- (setf z (/ (- (/ 16.0 (* x sqrtx)) 9.0) 7.0))
- (setf daie
- (/ (+ 0.28125 (dcsevl z aip1cs naip1)) (f2cl-lib:fsqrt sqrtx)))
- (go end_label)
- label40
- (setf sqrtx (f2cl-lib:fsqrt x))
- (setf z -1.0)
- (if (< x xbig) (setf z (- (/ 16.0 (* x sqrtx)) 1.0)))
- (setf daie
- (/ (+ 0.28125 (dcsevl z aip2cs naip2)) (f2cl-lib:fsqrt sqrtx)))
- (go end_label)
- end_label
- (return (values daie nil)))))
-
-